home *** CD-ROM | disk | FTP | other *** search
/ Light ROM 1 / LIGHT-ROM 1 (Amiga Library Services)(1994).iso / ffdisks / d963.lha / SIOD / scm / reg-mac.scm < prev    next >
Text File  |  1993-08-27  |  6KB  |  162 lines
  1. (macro define-machine 
  2.        (lambda (x) 
  3.                `(define ,(cadr x) (build-model ',(caddr x) ',(cadddr x)))))
  4.  
  5. (define (build-model registers controller)
  6.         (let ((machine (make-new-machine)))
  7.              (set-up-registers machine registers)
  8.              (set-up-controller machine controller)
  9.              machine))
  10.  
  11. (define (set-up-registers machine registers)
  12.         (mapc (lambda (register-name)
  13.                       (make-machine-register machine register-name))
  14.               registers))
  15.  
  16. (define (set-up-controller machine controller)
  17.         (build-instruction-list machine (cons '*start* controller)))
  18.  
  19. (define (build-instruction-list machine op-list)
  20.         (if (null? op-list)
  21.             '()
  22.             (let ((rest-of-instructions
  23.                   (build-instruction-list machine (cdr op-list))))
  24.                  (if (label? (car op-list))
  25.                      (sequence (declare-label machine
  26.                                               (car op-list)
  27.                                               rest-of-instructions)
  28.                                 rest-of-instructions)
  29.                      (cons (make-machine-instruction machine
  30.                                                      (car op-list))
  31.                            rest-of-instructions)))))
  32.  
  33. (define (label? expression)
  34.         (symbol? expression))
  35.  
  36. (define (make-machine-register machine name)
  37.         (remote-define machine name (make-register name)))
  38.  
  39. (define (make-register name)
  40.         (define contents nil)
  41.         (define (get) contents)
  42.         (define (set value)
  43.                 (set! contents value))
  44.         (define (dispatch message)
  45.                 (cond ((eq? message 'get) (get))
  46.                       ((eq? message 'set) set)
  47.                       (else (error "unknown request -- REGISTER"
  48.                                    (cons name mesage)))))
  49.         dispatch)
  50.  
  51. (define (get-contents register)
  52.         (register 'get))
  53.  
  54. (define (set-contents register value)
  55.         ((register 'set) value))
  56.  
  57. (define (declare-label machine label labeled-entry)
  58.         (let ((defined-labels (remote-get machine '*labels*)))
  59.              (if (memq label defined-labels)
  60.                  (error "Multiply-defined label" label)
  61.                  (sequence 
  62.                    (remote-define machine label labeled-entry)
  63.                    (remote-set machine
  64.                                '*labels*
  65.                                (cons label defined-labels))))))
  66.  
  67. (define (make-stack)
  68.         (define s '())
  69.         (define number-pushes 0)
  70.         (define max-depth 0)
  71.         (define (push x)
  72.                 (set! s (cons x s))
  73.                 (set! number-pushes (1+ number-pushes))
  74.                 (set! max-depth (max (lenght s) max-depth)))
  75.         (define (pop)
  76.                 (if (null? s)
  77.                     (error "empty stack --- POP")
  78.                     (let ((top (car s)))
  79.                          (set! s (cdr s))
  80.                          top)))
  81.         (define (initialize)
  82.                 (set! s '())
  83.                 (set! number-pushes 0)                 
  84.                 (set! max-depth 0))
  85.         (define (print-statistics)
  86.                 (print (list 'total-pushes: number-pushes
  87.                              'maximum-depth: max-depth))) 
  88.         (define (dispatch message)
  89.                 (cond ((eq? message 'push) push)
  90.                       ((eq? message 'pop) (pop))
  91.                       ((eq? message 'initialize) (initialize))
  92.                       ((eq? message 'print-statistics)
  93.                                     (print-statistics))
  94.                       (else (error "unknown request -- STACK" message))))
  95.         dispatch)
  96.  
  97. (define (pop stack)
  98.         (stack 'pop))
  99.  
  100. (define (push stack value)
  101.         ((stack 'push) value))
  102.  
  103. (define (make-new-machine)
  104.         (make-environment
  105.         (define *labels* '())
  106.         (define *the-stack* (make-stack))
  107.         (define (initialize-stack)
  108.                 (*the-stack* 'print-statistics)
  109.                 (*the-stack* 'initialize))
  110.         (define fetch get-contents)
  111.         (define *program-counter* '())
  112.         (define (execute sequence)
  113.                 (set! *program-counter* sequence)
  114.                 (if (null? *program-counter*)
  115.                     'done
  116.                     ((car *program-counter*))))
  117.         (define (normal-next-instruction)
  118.                 (execute (cdr *program-counter*)))
  119.         (define (assign register value)
  120.                 (set-contents register value)
  121.                 (normal-next-instruction))
  122.         (define (save reg)
  123.                 (push *the-stack* (get-contents reg))
  124.                 (normal-next-instruction))
  125.         (define (restore reg)
  126.                 (set-contents reg (pop *the-stack*))
  127.                 (normal-next-instruction))
  128.         (define (goto new-sequence)
  129.                 (execute new-sequence))
  130.         (define (branch predicate alternate-next)
  131.                 (if predicate
  132.                     (goto alternate-next)
  133.                     (normal-next-instruction)))
  134.         (define (perform operation)
  135.                 (normal-next-instruction))))
  136.  
  137. (define (remote-get machine variable)
  138.         (eval variable machine))
  139.  
  140. (define (remote-define machine variable value)
  141.         (eval (list 'define variable (list 'quote value))
  142.               machine))
  143.  
  144. (define (remote-set machine variable value)
  145.         (eval (list 'set! variable (list 'quote value))
  146.               machine))
  147.  
  148. (define (make-machine-instruction machine exp)
  149.         (eval (list 'lambda '() exp) machine))
  150.  
  151.  
  152. (define (remote-fetch machine register-name)
  153.         (get-contents (remote-get machine register-name)))
  154.  
  155. (define (remote-assign machine register-name value)
  156.         (set-contents (remote-get machine register-name) value)
  157.         'done)
  158.  
  159. (define (start machine)
  160.         (eval '(goto *start*) machine))
  161.  
  162.